home *** CD-ROM | disk | FTP | other *** search
/ Resource for Source: C/C++ / Resource for Source - C-C++.iso / codelib2 / v_02_04 / 2n04070a < prev    next >
Encoding:
Text File  |  1995-11-01  |  6.6 KB  |  215 lines
  1. UNIT PutEnv;
  2.   {$F+}                        (* for TP 5.0--force far procs *)
  3.   {Copyright (c) 1990 by Dennis Revie.  All rights reserved.
  4.  
  5.    This code may be used in any program, as long as the author
  6.    is credited either in the program or in the documentation.}
  7.  
  8. INTERFACE
  9.  
  10.  
  11. PROCEDURE PutEnvString(envirname : String; newenvirstrg : String);
  12.   (* envirname = 'ENVIRONMENTSTRING', etc....
  13.      newenvirstrg = 'add text'; etc
  14.      NOTES: --newenvirstrg REPLACES the old envirstrg.
  15.             --if newenvirstrg = '', then envirname is removed.
  16.   *)
  17.  
  18. PROCEDURE FreeEnvString;
  19.   (* returns environment to its original state *)
  20.  
  21. IMPLEMENTATION
  22.  
  23.  
  24. USES DOS;
  25.  
  26. TYPE
  27.   Environment = ARRAY[0..MaxInt] OF Char;
  28.   envptr = ^Environment;
  29.   Str255 = String[255];
  30. CONST
  31.   nul = #0;
  32. VAR
  33.   ExitSave: Pointer;     (* saves old ExitProc *)
  34.   oldenvplace : envptr;  (* pointer to the env *)
  35.   originalenvplace: Word;  (* segment of original environment *)
  36.   oldenvptrsize : Word;  (* size of the pointer *)
  37.  
  38.   PROCEDURE PutEnvString(envirname : String; newenvirstrg : String);
  39.  
  40.     FUNCTION StrUpCase(s : String) : String;
  41.       (* returns uppercase of string *)
  42.     VAR
  43.       i : WORD;
  44.     BEGIN
  45.       FOR i := 1 TO LENGTH(s) DO
  46.         s[i] := UPCASE(s[i]);
  47.       StrUpCase := s;
  48.     END;   (* StrUpCase *)
  49.  
  50.     FUNCTION GetEnvSize(envseg: WORD): WORD;
  51.       (* returns size of the environment *)
  52.     VAR
  53.       size: WORD;
  54.       newchar: CHAR;
  55.     BEGIN
  56.       IF (oldenvplace <> NIL) THEN
  57.         GetEnvSize := oldenvptrsize
  58.       ELSE BEGIN (* find end of environment *)
  59.         size := $0;
  60.         REPEAT
  61.           newchar := Chr(Mem[envseg:size]);
  62.           IF newchar = nul THEN BEGIN
  63.             Inc(size);
  64.             newchar := Chr(Mem[envseg:size]);
  65.           END ;
  66.           Inc(size);
  67.         UNTIL (newchar = nul); (* two consecutive #0 *)
  68.         GetEnvSize := size;
  69.       END;
  70.     END; (* GetEnvSize *)
  71.  
  72.   VAR
  73.     echar: Char;
  74.     ct, envofs, envtop, eptrct, envptrsize, currentenvsize : Word;
  75.     currentenvstrg : Str255;
  76.     eptr : envptr;
  77.     envpointer : envptr;
  78.     nextenvname : Str255;
  79.     envseg : Word;
  80.   BEGIN
  81.     envseg := MemW[PrefixSeg:$2C];  (* where the environment is *)
  82.     envirname := StrUpCase(envirname);
  83.  
  84.     envofs := GetEnvSize(envseg);   (* get the size of the environment *)
  85.     currentenvsize := envofs;       (* save the size *)
  86.  
  87.     currentenvstrg := GetEnv(envirname); (* get old environment *)
  88.     Inc(envofs, Length(newenvirstrg) + 15 + Length(envirname) + 2);
  89.     (* 15 to round up to next 16 bytes; 2  for '=' & nul *)
  90.     Dec(envofs, Length(currentenvstrg) + 1 (* #0 *));
  91.     IF (Length(newenvirstrg) = 0) AND (envofs > Length(envirname)) THEN
  92.       Dec(envofs, Length(envirname));
  93.     IF envofs > currentenvsize THEN
  94.       envptrsize := envofs
  95.     ELSE
  96.       envptrsize := currentenvsize;
  97.  
  98.     IF envptrsize > MaxAvail THEN
  99.       EXIT; (* not enough memory *)
  100.     GetMem(envpointer, envptrsize);
  101.     IF envpointer = NIL THEN
  102.       EXIT; (* not enough memory *)
  103.  
  104.     IF Ofs(envpointer^) <> 0 THEN
  105.       (* to force an ofs of 0, move to the next segment *)
  106.       eptr := Ptr(Succ(Seg(envpointer^)), 0)
  107.     ELSE
  108.       eptr := envpointer;
  109.  
  110.     (* now, copy the old to the new env, and change "envirname" *)
  111.     envtop := 0;
  112.     eptrct := 0;
  113.     IF Length(currentenvstrg) = 0 THEN BEGIN
  114.       (* not previously there, add new string *)
  115.       IF Length(newenvirstrg) > 0 THEN BEGIN (* add it *)
  116.         FOR ct := 1 TO Length(envirname) DO BEGIN
  117.           (* copy current env to the beginning *)
  118.           eptr^[eptrct] := envirname[ct];
  119.           Inc(eptrct);
  120.         END;
  121.         eptr^[eptrct] := '='; (* add the equals sign *)
  122.         Inc(eptrct);
  123.  
  124.         FOR ct := 1 TO Length(newenvirstrg) DO BEGIN (* add new string *)
  125.           eptr^[eptrct] := newenvirstrg[ct];
  126.           Inc(eptrct);
  127.         END;
  128.         eptr^[eptrct] := nul; (* ends in nul *)
  129.         Inc(eptrct);
  130.       END;
  131.  
  132.       FOR ct := 0 TO currentenvsize-1 DO (* move rest of env *)
  133.         eptr^[eptrct + ct] := Chr(Mem[envseg:ct]);
  134.       Inc(eptrct, currentenvsize);
  135.     END ELSE BEGIN  (* change old string *)
  136.       WHILE envtop <= currentenvsize DO BEGIN
  137.         nextenvname := '';
  138.         REPEAT (* copy next env name *)
  139.           echar := Chr(Mem[envseg:envtop]);
  140.           nextenvname := nextenvname + Upcase(echar);
  141.           eptr^[eptrct] := echar;
  142.           Inc(envtop);
  143.           Inc(eptrct);
  144.         UNTIL (echar = nul) OR (echar = '=');
  145.         IF nextenvname = envirname + '=' THEN BEGIN (* substitute new one *)
  146.           WHILE echar <> nul DO BEGIN (* skip over old string *)
  147.             echar := Chr(Mem[envseg:envtop]);
  148.             Inc(envtop);
  149.           END;
  150.  
  151.           IF Length(newenvirstrg) = 0 THEN (* delete it *)
  152.             DEC(eptrct, Length(nextenvname))
  153.           ELSE BEGIN
  154.             FOR ct := 1 TO Length(newenvirstrg) DO BEGIN (* add new one *)
  155.               eptr^[eptrct] := newenvirstrg[ct];
  156.               Inc(eptrct);
  157.             END;
  158.             eptr^[eptrct] := nul; (* nul at end *)
  159.             Inc(eptrct);
  160.           END;
  161.         END ELSE BEGIN
  162.           WHILE (echar <> nul) AND (envtop <= envofs) DO BEGIN
  163.             echar := Chr(Mem[envseg:envtop]);
  164.             eptr^[eptrct] := echar;
  165.             Inc(eptrct);
  166.             Inc(envtop);
  167.           END;
  168.         END (* if *);
  169.  
  170.       END (* while *);
  171.     END (* if *);
  172.     eptr^[eptrct] := nul; (* end with double nul *)
  173.     Inc(eptrct);
  174.     eptr^[eptrct] := nul;
  175.  
  176.     (* now, reassign the environment pointer to new strings *)
  177.     IF currentenvsize >= eptrct THEN BEGIN
  178.       (* it's shrunk, put into old env *)
  179.       FOR ct := 0 TO eptrct DO
  180.         Mem[envseg:ct] := Ord(eptr^[ct]);
  181.       FreeMem(envpointer, envptrsize);
  182.     END ELSE BEGIN (* repoint to new pointer *)
  183.       IF (oldenvplace <> NIL) THEN
  184.         FreeMem(oldenvplace, oldenvptrsize);
  185.       oldenvplace := envpointer;
  186.       oldenvptrsize := envptrsize;
  187.       (* reassign envseg *)
  188.       MemW[PrefixSeg:$2C] := Seg(eptr^);
  189.     END;
  190.   END;  (* PutEnvString *)
  191.  
  192.  
  193.   PROCEDURE FreeEnvString;
  194.   BEGIN
  195.     IF (oldenvplace <> NIL) THEN BEGIN
  196.       FreeMem(oldenvplace, oldenvptrsize);
  197.       oldenvplace := NIL;
  198.     END;
  199.     MemW[PrefixSeg:$2C] := originalenvplace;
  200.   END; (* FreeEnvString *)
  201.  
  202.   {$F+}
  203.   PROCEDURE PutEnvExit;
  204.   BEGIN
  205.     FreeEnvString;
  206.     ExitProc := ExitSave;
  207.   END; (* PutEnvExit *)
  208.  
  209. BEGIN (* PutEnv *)
  210.   ExitSave := ExitProc;
  211.   ExitProc := @PutEnvExit;
  212.   oldenvplace := NIL;
  213.   originalenvplace := MemW[PrefixSeg:$2C];
  214. END. (* PutEnv *)
  215.